home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / postnt.zip / ZIP_DEM1.PAS < prev   
Pascal/Delphi Source File  |  1991-02-23  |  8KB  |  385 lines
  1. program POSTNT;
  2.  
  3. { Date: 02-25-90 }
  4.  
  5. (*********************************************************************)
  6. (* POSTNT was written as an exercise. The intent was to produce      *)
  7. (* a program which could print US Postal Service POSTNET barcodes    *)
  8. (* (those lines on lower right corner of some of the letters         *)
  9. (* you get in the mail) which could be used for demonstration        *)
  10. (* and information purposes. As it turned out, the barcodes          *)
  11. (* actually are 'readable' on a barcode sorter.                      *)
  12. (*                                                                   *)
  13. (*                                                                   *)
  14. (* This program was written by Dave Barrett, CS 76314,1004           *)
  15. (* This program is put in the public domain with the following       *)
  16. (* conditions:                                                       *)
  17. (*                                                                   *)
  18. (* 1) This portion of the documentation must remain with the source. *)
  19. (* 2) If you make any improvements to the program please post them   *)
  20. (*    so others can enjoy them.                                      *)
  21. (* 3) This program must be distributed without charge whether used   *)
  22. (*    alone or included as part of another program.                  *)
  23. (* 4) Please include the accompanying file POSTNT.DOC along with     *)
  24. (*    this file                                                      *)
  25. (*********************************************************************)
  26.  
  27.  
  28.  
  29. uses dos,crt,printer;
  30.  
  31. type
  32.  NumberSet = set of char;
  33.  
  34. var
  35.  CheckDigit,
  36.  ZIPString : string[200];
  37.  Afield,
  38.  Bfield : string [10];
  39.  Numbers : NumberSet;
  40.  CheckNumber,
  41.  result : integer;
  42.  
  43.  ZIPCodeIsValid : boolean;
  44.  
  45. procedure PrintFullBar;
  46. begin
  47.  Write(Lst,char(255));
  48.  Write(Lst,char(255));
  49.  Write(Lst,char(255));
  50.  Write(Lst,char(255));
  51. end;
  52.  
  53. procedure PrintFullSpace;
  54. begin
  55.  Write(Lst,char(0));
  56.  Write(Lst,char(0));
  57.  Write(Lst,char(0));
  58.  Write(Lst,char(0));
  59.  Write(Lst,char(0));
  60.  Write(Lst,char(0));
  61.  Write(Lst,char(0));
  62.  Write(Lst,char(0));
  63. end;
  64.  
  65. procedure PrintPartSpace;
  66. begin
  67.  Write(Lst,char(0));
  68.  Write(Lst,char(0));
  69.  Write(Lst,char(0));
  70.  Write(Lst,char(0));
  71.  Write(Lst,char(0));
  72.  Write(Lst,char(0));
  73.  Write(Lst,char(0));
  74. end;
  75.  
  76. procedure PrintHalfBar;
  77. begin
  78.  Write(Lst,char(15));
  79.  Write(Lst,char(15));
  80.  Write(Lst,char(15));
  81.  Write(Lst,char(15));
  82. end;
  83.  
  84. procedure PrintFrameBar;
  85. begin
  86.  PrintFullBar;
  87.  PrintFullSpace;
  88. end;
  89.  
  90. procedure Print0;
  91. begin
  92.  PrintFullBar;
  93.  PrintFullSpace;
  94.  PrintFullBar;
  95.  PrintPartSpace;
  96.  PrintHalfBar;
  97.  PrintFullSpace;
  98.  PrintHalfBar;
  99.  PrintPartSpace;
  100.  PrintHalfBar;
  101.  PrintFullSpace;
  102. end;
  103.  
  104. procedure Print1;
  105. begin
  106.  PrintHalfBar;
  107.  PrintFullSpace;
  108.  PrintHalfBar;
  109.  PrintPartSpace;
  110.  PrintHalfBar;
  111.  PrintFullSpace;
  112.  PrintFullBar;
  113.  PrintPartSpace;
  114.  PrintFullBar;
  115.  PrintFullSpace;
  116. end;
  117.  
  118. procedure Print2;
  119. begin
  120.  PrintHalfBar;
  121.  PrintFullSpace;
  122.  PrintHalfBar;
  123.  PrintPartSpace;
  124.  PrintFullBar;
  125.  PrintFullSpace;
  126.  PrintHalfBar;
  127.  PrintPartSpace;
  128.  PrintFullBar;
  129.  PrintFullSpace;
  130. end;
  131.  
  132. procedure Print3;
  133. begin
  134.  PrintHalfBar;
  135.  PrintFullSpace;
  136.  PrintHalfBar;
  137.  PrintPartSpace;
  138.  PrintFullBar;
  139.  PrintFullSpace;
  140.  PrintFullBar;
  141.  PrintPartSpace;
  142.  PrintHalfBar;
  143.  PrintFullSpace;
  144. end;
  145.  
  146. procedure Print4;
  147. begin
  148.  PrintHalfBar;
  149.  PrintFullSpace;
  150.  PrintFullBar;
  151.  PrintPartSpace;
  152.  PrintHalfBar;
  153.  PrintFullSpace;
  154.  PrintHalfBar;
  155.  PrintPartSpace;
  156.  PrintFullBar;
  157.  PrintFullSpace;
  158. end;
  159.  
  160. procedure Print5;
  161. begin
  162.  PrintHalfBar;
  163.  PrintFullSpace;
  164.  PrintFullBar;
  165.  PrintPartSpace;
  166.  PrintHalfBar;
  167.  PrintFullSpace;
  168.  PrintFullBar;
  169.  PrintPartSpace;
  170.  PrintHalfBar;
  171.  PrintFullSpace;
  172. end;
  173.  
  174. procedure Print6;
  175. begin
  176.  PrintHalfBar;
  177.  PrintFullSpace;
  178.  PrintFullBar;
  179.  PrintPartSpace;
  180.  PrintFullBar;
  181.  PrintFullSpace;
  182.  PrintHalfBar;
  183.  PrintPartSpace;
  184.  PrintHalfBar;
  185.  PrintFullSpace;
  186. end;
  187.  
  188. procedure Print7;
  189. begin
  190.  PrintFullBar;
  191.  PrintFullSpace;
  192.  PrintHalfBar;
  193.  PrintPartSpace;
  194.  PrintHalfBar;
  195.  PrintFullSpace;
  196.  PrintHalfBar;
  197.  PrintPartSpace;
  198.  PrintFullBar;
  199.  PrintFullSpace;
  200. end;
  201.  
  202. procedure Print8;
  203. begin
  204.  PrintFullBar;
  205.  PrintFullSpace;
  206.  PrintHalfBar;
  207.  PrintPartSpace;
  208.  PrintHalfBar;
  209.  PrintFullSpace;
  210.  PrintFullBar;
  211.  PrintPartSpace;
  212.  PrintHalfBar;
  213.  PrintFullSpace;
  214. end;
  215.  
  216. procedure Print9;
  217. begin
  218.  PrintFullBar;        { 4 }
  219.  PrintFullSpace;      { 8 }
  220.  PrintHalfBar;        { 4 }
  221.  PrintPartSpace;      { 7 }
  222.  PrintFullBar;        { 4 }
  223.  PrintFullSpace;      { 8 }
  224.  PrintHalfBar;        { 4 }
  225.  PrintPartSpace;      { 7 }
  226.  PrintHalfBar;        { 4 }
  227.  PrintFullSpace;      { 8 }
  228. end;
  229.  
  230. procedure PrintBarCode(s:integer);
  231. var
  232.  i : integer;
  233. begin
  234.  PrintFrameBar;
  235.  i:=1;
  236.  while i <= Length(ZIPString) do
  237.   begin
  238.    case ZIPString[i] of
  239.     '0':Print0;
  240.     '1':Print1;
  241.     '2':Print2;
  242.     '3':Print3;
  243.     '4':Print4;
  244.     '5':Print5;
  245.     '6':Print6;
  246.     '7':Print7;
  247.     '8':Print8;
  248.     '9':Print9;
  249.    end;
  250.    i:=i+1;
  251.   end;
  252.  PrintFrameBar;
  253.  if s=1 then
  254.   else
  255.    Writeln(Lst);
  256. end;
  257.  
  258. procedure DetermineCheckDigit;
  259. var
  260.  zip_digit,
  261.  zip_total,
  262.  i : integer;
  263. begin
  264.  zip_total:=0;
  265.  for i:=1 to Length(ZIPString) do
  266.   begin
  267.    Val(ZIPString[i],zip_digit,result);
  268.    zip_total:=zip_total+zip_digit;
  269.   end;
  270.  CheckNumber:=10 - (zip_total MOD 10);
  271.  Str(CheckNumber:1,CheckDigit);
  272.  ZIPString:=ZIPString+CheckDigit;
  273. end;
  274.  
  275. procedure VerifyDigits;
  276. var
  277.  i : integer;
  278. begin
  279.  Numbers:=['0','1','2','3','4','5','6','7','8','9'];
  280.  ZIPCodeIsValid:=true;
  281.  if ((Copy(ZIPString,1,1)='A') OR (Copy(ZIPString,1,1)='a'))
  282.     AND ((Copy(ZIPString,2,1)='B') OR (Copy(ZIPString,2,1)='b'))
  283.     AND (Length(ZIPString)=13) then
  284.   ZIPString:=Copy(ZIPString,3,11);
  285.  if (Length(ZIPString)=5) then
  286.   begin
  287.    for i:=1 to 5 do
  288.     if ZIPString[i] in Numbers then
  289.      begin end
  290.     else
  291.      ZIPCodeIsValid:=false;
  292.   end
  293.  else
  294.   if (Length(ZIPString)=9) then
  295.    begin
  296.     for i:=1 to 9 do
  297.      if ZIPString[i] in Numbers then
  298.       begin end
  299.      else
  300.       ZIPCodeIsValid:=false;
  301.    end
  302.   else
  303.    if (Length(ZIPString)=10) AND (Pos('-',ZIPString)=6) then
  304.     begin
  305.      Delete(ZIPString,6,1);
  306.      for i:=1 to 9 do
  307.       if ZIPString[i] in Numbers then
  308.        begin end
  309.       else
  310.        ZIPCodeIsValid:=false;
  311.     end
  312.    else
  313.     if (Length(ZIPString)=11) then
  314.      begin
  315.       for i:=1 to 11 do
  316.        if ZIPString[i] in Numbers then
  317.         begin end
  318.        else
  319.         ZIPCodeIsValid:=false;
  320.      end
  321.     else
  322.      ZIPCodeIsValid:=false;
  323. end;
  324.  
  325. procedure Initialization;
  326. begin
  327.  if ParamCount = 1 then
  328.   begin
  329.    ZIPString:=ParamStr(1);
  330.    VerifyDigits;
  331.   end
  332.  else
  333.   ZIPCodeIsValid:=false;
  334. end;
  335.  
  336. begin
  337.  ZIPString:='';
  338.  Initialization;
  339.  if ZIPCodeIsValid then
  340.   begin
  341.    if Length(ZIPString)=11 then
  342.     begin
  343.      Afield:=Copy(ZIPString,1,5);
  344.      Bfield:=Copy(ZIPString,6,6);
  345.      ZIPString:=Afield;
  346.      DetermineCheckDigit;
  347.      Write(Lst,char(27),'Z',char(116),char(1));
  348.      PrintBarCode(1);    { no CR/LF }
  349.      Write(Lst,'    ');
  350.      ZIPString:=Bfield;
  351.      DetermineCheckDigit;
  352.      Write(Lst,char(27),'Z',char(174),char(1));
  353.      PrintBarCode(0);       { CR/LF ok }
  354.     end
  355.    else
  356.     begin
  357.       DetermineCheckDigit;
  358.       if Length(ZIPSTring) = 6 then
  359.        Write(Lst,char(27),'Z',char(116),char(1))
  360.       else
  361.        Write(Lst,char(27),'Z',char(92),char(2));
  362.       PrintBarCode(0);       { CR/LF ok }
  363.      end;
  364.   end
  365.  else
  366.   begin
  367.  
  368.    TextColor(White);
  369.    TextBackground(Black);
  370.    ClrScr;
  371.    Writeln;
  372.    Writeln('Usage is ....');
  373.    Writeln;
  374.    Writeln('POSTNT zipcode');
  375.    Writeln;
  376.    Writeln('Where  zipcode  is a 5, 9, or 10 character ZIP in the form');
  377.    Writeln('    99999    or    999999999    or    99999-9999');
  378.    Writeln('or an AB field 11 character ZIP in the form');
  379.    Writeln('    AB99999999999');
  380.    Writeln('Note that in the AB field example above the use of   AB');
  381.    Writeln('preceeding the 11 digit ZIP is required!');
  382.    Writeln;
  383.   end;
  384. end.
  385.